Delphi Developer's Kit 1996/Delphi Developer's Kit 1996.iso/power/dirvcl/director.pas

Pascal/Delphi Source File | 1995-12-22 | 21KB | 696 lines

unit Director;
{Copyright Dr A. GUERIN and PASCALISSIME
    (GUERIN Alain Georges : Compuserve  100034,2305)
 This is a barterfreeware: if you find it valuable, send me something you built
 YOURSELF in Delphi and you think it has more or less the same value and is as
 public as this piece of software is. (So if it's used in a commercial software,
 sorry for you business people, but you'll have to build something public and
 free. There are particular conditions for Borland International: it's totally
 free for all the company and company people, as long as they belong to B.I.
 And eventually, it's a complete freeware for all TeamB people as my
 debt is so high, I can never reimburse it)
 If you don't have anything of this kind now, feel free to wait the necessary
 time. (I will not think that your are lazy or a beginner <g>, as I have no way
  to know when you got it, but please as I'm 49, don't wait to much)
 Distribution is free, as long as all the files are unmodified and kept
 together.
 As usual there no garanty, implied or not. Use under your own responsability,
 but commentaries ( even critics) in English (or in French) are wellcome}
interface

uses
    Classes;

CONST
    MaxDirectoryLength = 79;
    RS_InvalidDirectoryName        = 33001;
    RS_InvalidFilterName             = 33002;
   RS_InvalidDirectoryRestriction     = 33003;
   RS_InvalidDirectoryExclusion         = 33004;
   KVersion = 'V 1.0a - 17/05/95';

type
    T_DirectoryName = STRING[MaxDirectoryLength];
    TDirectory = class(TComponent)
   {With this component you can get filenames in a directory
       You can choose which kind of files you want by including
      hidden, sysfile, volumeID or Directory attributes or by
      excluding archive, readonly and even normal files.
      You can choose to recurse into subdirectories or not,
      and if so, you can choose in which kind of subdir you
      will recurse.
      For example
          you can get archive and/or hidden files in the current
         directory and in all the archive and/or system sub dir
         by excluding readonly and normal file, including hidden
         files, including system directories and excluding normal
         and readonly directories
       In this version, this kind of directory filter is only
      implemented for subdirectories.
      For getting the results, you have to implement the found method
      in the target program and read through SelectedFileName in it.
      You can also implement a cancel mechanism where you can trigger
      the DoStop method}

   private
     { Private-declarations }
        FExcludeNormalFiles : BOOLEAN;
      FExcludeReadOnlyFiles : BOOLEAN;
      FExcludeArchiveFiles : BOOLEAN;
      FIncludeHiddenFiles : BOOLEAN;
      FIncludeSystemFiles : BOOLEAN;
      FIncludeVolumeID : BOOLEAN;
      FIncludeDirectoryFiles : BOOLEAN;
        FExcludeNormalDir : BOOLEAN;
      FExcludeReadOnlyDir : BOOLEAN;
      FExcludeArchiveDir : BOOLEAN;
      FIncludeHiddenDir : BOOLEAN;
      FIncludeSystemDir : BOOLEAN;
        FInSubDirectories : BOOLEAN;
      FOnlyDirectories : BOOLEAN;
        FStopStatus : BOOLEAN;
        FInitialDirectory : PString;
        FDirectoryInTreatment : PString;
        FSelectedFileName : PString;
        FFileFilter : PSTRING;
        FDirectoryFilter : PSTRING;
        FOnFound : TNotifyEvent;
        FOnSearchStatus : TNotifyEvent;
      FVersion : PString;
          SearchFilesMask : BYTE;
      SearchDirMask : BYTE;
        ExcludedFilesMask : BYTE;
      ExcludedDirMask : BYTE;
        PROCEDURE SetInitial(Value : T_DirectoryName);
        FUNCTION  GetInitial : T_DirectoryName;
        PROCEDURE SetExcludeNormalFiles(Value : BOOLEAN);
      PROCEDURE SetExcludeReadOnlyFiles (Value : BOOLEAN);
      PROCEDURE SetExcludeArchiveFiles (Value : BOOLEAN);
      PROCEDURE SetIncludeHiddenFiles (Value : BOOLEAN);
      PROCEDURE SetIncludeSystemFiles (Value : BOOLEAN);
      PROCEDURE SetIncludeVolumeID (Value : BOOLEAN);
      PROCEDURE SetIncludeDirectoryFiles (Value : BOOLEAN);
        PROCEDURE SetExcludeNormalDir (Value : BOOLEAN);
      PROCEDURE SetExcludeReadOnlyDir (Value : BOOLEAN);
      PROCEDURE SetExcludeArchiveDir (Value : BOOLEAN);
      PROCEDURE SetIncludeHiddenDir (Value : BOOLEAN);
      PROCEDURE SetIncludeSystemDir (Value : BOOLEAN);
        PROCEDURE SetInSubDirectories (Value : BOOLEAN);
       PROCEDURE SetOnlyDirectories (Value : BOOLEAN);
        PROCEDURE SetStopStatus(Value : BOOLEAN);
        PROCEDURE SetFileFilter(CONST Value : STRING);
        FUNCTION  GetFileFilter : String;
        PROCEDURE SetDirectoryFilter(CONST Value : STRING);
        FUNCTION  GetDirectoryFilter: String;
        FUNCTION  GetDirectoryInTreatment : T_DirectoryName;
        PROCEDURE SetDirectoryInTreatment(Value : T_DirectoryName);
        FUNCTION  GetSelectedFileName : T_DirectoryName;
        PROCEDURE SetSelectedFileName (Value : T_DirectoryName);
      PROCEDURE SetVersion(Value : String);
      FUNCTION  GetVersion : String;
  protected
        property  StopStatus : BOOLEAN write SetStopStatus DEFAULT True;
  public
        property  Stopped : BOOLEAN read FStopStatus;
        property  DirectoryInTreatment : T_DirectoryName
                                                                read     GetDirectoryInTreatment
                                                                Write SetDirectoryInTreatment;
        property  SelectedFileName : T_DirectoryName read GetSelectedFileName
                                                                    Write SetSelectedFileName;
        CONSTRUCTOR Create(AOwner : TComponent); OVERRIDE;
        DESTRUCTOR Destroy;
        PROCEDURE Execute;
        PROCEDURE DoStop;
  published
     { Published-declarations }
      property Version : String read GetVersion write SetVersion;
        property OnFound: TNotifyEvent read FOnFound write FOnFound;
        property OnSearchStatus : TNotifyEvent    read FOnSearchStatus
                                                            write FOnSearchStatus;
        property InitialDir : T_DirectoryName     read GetInitial write SetInitial;
        property ExcludeNormalFiles : BOOLEAN read FExcludeNormalFiles
                                              write SetExcludeNormalFiles;
      property ExcludeReadOnlyFiles : BOOLEAN read FExcludeReadOnlyFiles
                                              write SetExcludeReadOnlyFiles;
      property ExcludeArchiveFiles : BOOLEAN read FExcludeArchiveFiles
                                              write SetExcludeArchiveFiles;
      property IncludeHiddenFiles : BOOLEAN read FIncludeHiddenFiles
                                              write SetIncludeHiddenFiles;
      property IncludeSystemFiles : BOOLEAN read FIncludeSystemFiles
                                              write SetIncludeSystemFiles;
      property IncludeVolumeID : BOOLEAN read FIncludeVolumeID
                                              write SetIncludeVolumeID;
      property IncludeDirectoryFiles : BOOLEAN read FIncludeDirectoryFiles
                                              write SetIncludeDirectoryFiles;
        property ExcludeNormalDir : BOOLEAN read FExcludeNormalDir
                                              write SetExcludeNormalDir;
      property ExcludeReadOnlyDir : BOOLEAN read FExcludeReadOnlyDir
                                              write SetExcludeReadOnlyDir;
      property ExcludeArchiveDir : BOOLEAN read FExcludeArchiveDir
                                              write SetExcludeArchiveDir;
      property IncludeHiddenDir : BOOLEAN read FIncludeHiddenDir
                                              write SetIncludeHiddenDir;
      property IncludeSystemDir : BOOLEAN read FIncludeSystemDir
                                              write SetIncludeSystemDir;
        property InSubDirectories : BOOLEAN read FInSubDirectories
                                                            write SetInSubDirectories;
      property OnlyDirectories : BOOLEAN read FOnlyDirectories
                                                          write SetOnlyDirectories;
        property FileFilter : STRING read GetFileFilter Write SetFileFilter;
        property DirectoryFilter: STRING read GetDirectoryFilter
                                                    Write SetDirectoryFilter;
    end;


    procedure Register;

implementation

uses
    Messages,
    Sysutils,
    WinProcs,
    WinTypes;

TYPE

    EDirectoryError = Class(Exception);

    FUNCTION DirectoryValide(TestedDirectory: T_DirectoryName) : BOOLEAN;

    VAR
        MaxName,
        MaxExtension,
        Letter : BYTE;
        PreviousLetter : CHAR;
        InName : BOOLEAN;

    BEGIN
        MaxName := 0;
        MaxExtension :=0;
        Letter := 1;
        InName := TRUE;
        Result := TRUE;
        PreviousLetter:=' ';
        WHILE Result AND (Letter <= Length(TestedDirectory)) DO
        BEGIN
            CASE TestedDirectory[Letter] OF
                '\': BEGIN
                    Result := (PreviousLetter<>'\') AND (MaxName<=8)
                                        AND (MaxExtension<=3);
                    MaxName:=0;
                    MaxExtension:=0;
                END;
                '.': BEGIN
                    Result := (MaxName > 0) AND (MaxName<=8);
                    MaxName:=0;
                    MaxExtension:=0;
                    InName:=FALSE;
                END;
                #0..' ','/','+','=','*','?','(',')','[',']',',','|','<','>':
                {Dos forbidden characters in a filename}
                    Result := FALSE;
                ':': BEGIN
                    Result := Letter=2;
                    MaxName:=0;
                END
                ELSE
                    IF InName THEN
                        INC(MaxName)
                    ELSE
                        INC(MaxExtension);
            END;
            PreviousLetter := TestedDirectory[Letter];
            INC(Letter);
        END;
        Result := Result AND (MaxName <=8) AND (MaxExtension<=3);
        IF NOT Result THEN
            raise EDirectoryError.CreateResFmt(RS_InvalidDirectoryName,
                                                                                [TestedDirectory]);
    END;

    FUNCTION ValidFilter(CONST TestedFilter : String) : BOOLEAN;

    CONST
        Jeux_Interdits : SET OF CHAR =
        {French joke, it's untranslatable}
            [#0..' ','[',']','\','/','|','=','+','>','<',',',';','.',':','º'];
    VAR
        TestFilter : STRING;
        Letter : BYTE;
        Extension : String;

    BEGIN
        TestFilter:= Lowercase(Copy(TestedFilter,1,11));
        IF POS('.', TestFilter)> 1 THEN
        BEGIN
        {If the filter is too long, it's false but it does no matter: we cut it}
            Extension:= Copy(TestFilter, POS('.', TestFilter)+1,3);
            Delete(TestFilter, POS('.', TestFilter),255);
        END
        ELSE
            Extension := '';
        TestFilter := COPY(TestFilter,1,8);
        Letter := 1;
        Result := True;
        WHILE (Letter <= LENGTH(TestFilter)) AND Result DO
        BEGIN
            Result := NOT (TestFilter[Letter] in Jeux_Interdits);
            INC(Letter);
        END;
        Letter := 1;
        WHILE (Letter <= LENGTH(Extension)) AND Result DO
        BEGIN
            Result := NOT (Extension[1] in Jeux_Interdits);
            INC(Letter);
        END;
        IF NOT Result THEN
            Raise EDirectoryError.CreateResfmt(RS_InvalidFilterName, [TestedFilter]);
    END;

    PROCEDURE ProcessMessages;

    {as there is no Tapplication available here}

    VAR
        Msg: TMsg;

    BEGIN
        if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
        begin
            if Msg.Message <> WM_QUIT then
            begin
                TranslateMessage(Msg);
                DispatchMessage(Msg);
            end
      end;
    END;


    CONSTRUCTOR TDirectory.Create;

    VAR
        LInitial : T_DirectoryName;

    BEGIN
        INHERITED Create(AOwner);
        FInitialDirectory:=NullStr;
        FDirectoryInTreatment :=NullStr;
        FSelectedFileName :=NullStr;
        FFileFilter :=NullStr;
        AssignStr(FFileFilter, '*.*');
        FDirectoryFilter :=NullStr;
        AssignStr(FDirectoryFilter, '*.*');
      FVersion := NullStr;
      AssignStr(FVersion, KVersion);
          SearchFilesMask := faArchive OR faReadOnly;
        ExcludedFilesMask :=0;
      SearchDirMask :=faDirectory;
      ExcludedDirMask :=0;
    END;

    DESTRUCTOR TDirectory.Destroy;

    BEGIN
        DisposeStr(FInitialDirectory);
        DisposeStr(FDirectoryInTreatment);
        DisposeStr(FSelectedFileName);
        DisposeStr(FFileFilter);
        DisposeStr(FDirectoryFilter);
      DisposeStr(FVersion);
        INHERITED Destroy;
    END;

    PROCEDURE TDirectory.Execute;

    VAR
        Filter : String;

        PROCEDURE ReadDirectory(Directory_to_Read : T_DirectoryName);

        VAR
            CurrentPath : T_DirectoryName;
            MyDosIOError : INTEGER;
            SearchInfo : TSearchRec;

            PROCEDURE SearchFiles;

            VAR
                FileSearchInfo : TSearchRec;
                MaskFileName : T_DirectoryName;

            BEGIN
                MaskFileName := CurrentPath+FFileFilter^;
                MyDosIOError := FindFirst(MaskFileName, SearchFilesMask,
                                                                                FileSearchInfo);
                IF MyDosIOError = 0 THEN
            {0 if something found, else negative DOS error code}
                REPEAT
                    WITH FileSearchInfo DO
                        IF ((Name<>'.') AND ( Name<>'..'))
                  {Don't take in account Directory itself or its parent
                   directory}
                  AND (Attr AND  ExcludedFilesMask = 0)
                  {There is nothing in common = no exclusion}
                  AND NOT (((Attr=0)OR(Attr=faDirectory)) AND ExcludeNormalFiles) THEN
                  {It's not a normal file or a normal directory
                                               when normal files are excluded}
                        BEGIN
                      IF FOnlyDirectories AND (Attr AND faDirectory=faDirectory)
                     OR NOT FOnlyDirectories THEN
                     BEGIN
                                SelectedFileName:=
                                            CurrentPath+FileSearchInfo.Name;
                        {Signal a new file name}
                                if Assigned(FOnFound) then FOnFound(Self);
                      END;
                        END;
               ProcessMessages;
                    MyDosIOError := FindNext(FileSearchInfo);
                UNTIL (MyDosIOError < 0) OR Stopped;
            END;

        BEGIN
            CurrentPath := Directory_To_Read;
            IF CurrentPath = '' THEN
                GetDir(0, CurrentPath);
            IF NOT (CurrentPath[Length(CurrentPath)] IN ['\',':']) THEN
                CurrentPath:=CurrentPath+'\';
            MyDosIOError := FindFirst(CurrentPath+FDirectoryFilter^,
                                                             SearchDirMask, SearchInfo);
            IF MyDosIOError = 0 THEN
            BEGIN
                REPEAT
                    WITH SearchInfo DO
                        IF ((Name<>'.') AND ( Name<>'..'))
                  {Don't take in account Directory itself or its parent
                   directory}
                  AND (Attr AND faDirectory=faDirectory) THEN
                  {Select only Directories}
                        BEGIN
                            DirectoryInTreatment := CurrentPath;
                            IF InSubDirectories
                     AND (Attr AND  ExcludedDirMask = 0)
                     {recurse in sub dir if they fit with directories selection
                      criteria}
                     AND NOT((Attr=faDirectory) AND ExcludeNormalDir) THEN
                     {but not if it's a normal dir when normal dirs are
                     excluded}
                                ReadDirectory(CurrentPath+Name);
                        END;
                    ProcessMessages;
                    MyDosIOError := FindNext(SearchInfo);
                UNTIL (MyDosIOError < 0) OR Stopped;
                IF Stopped THEN
                    Exit;
                SearchFiles
            END;
        END;

    BEGIN
        StopStatus := FALSE;
        IF DirectoryFilter = '' THEN
            Filter := '*.*'
        ELSE
            Filter := DirectoryFilter;
        ReadDirectory(FInitialDirectory^);
        StopStatus := TRUE;
    END;

    PROCEDURE TDirectory.DoStop;

    BEGIN
        StopStatus := True;
    END;


    PROCEDURE TDirectory.SetInitial(Value : T_DirectoryName);

    BEGIN
        IF NOT DirectoryValide(Value) THEN
          Exit;
        IF FInitialDirectory^ <> Value THEN
            AssignStr( FInitialDirectory,Value);
    END;

    FUNCTION TDirectory.GetInitial :T_DirectoryName;

    BEGIN
        Result := FInitialDirectory^;
    END;

    PROCEDURE TDirectory.SetExcludeNormalFiles (Value : BOOLEAN);

    BEGIN
        IF Value <> FExcludeNormalFiles THEN
            FExcludeNormalFiles := Value;
    END;

   PROCEDURE TDirectory.SetExcludeReadOnlyFiles (Value : BOOLEAN);

   BEGIN
       IF Value <> FExcludeReadOnlyFiles THEN
      BEGIN
          FExcludeReadOnlyFiles := Value;
         IF Value THEN
             ExcludedFilesMask := ExcludedFilesMask OR faReadOnly
         ELSE
             ExcludedFilesMask := ExcludedFilesMask AND NOT faReadOnly
      END;
   END;

   PROCEDURE TDirectory.SetExcludeArchiveFiles (Value : BOOLEAN);

   BEGIN
       IF Value <> FExcludeArchiveFiles THEN
      BEGIN
          FExcludeArchiveFiles := Value;
         IF Value THEN
             ExcludedFilesMask := ExcludedFilesMask OR faArchive
         ELSE
             ExcludedFilesMask := ExcludedFilesMask AND NOT faArchive
      END;
   END;

   PROCEDURE TDirectory.SetIncludeHiddenFiles (Value : BOOLEAN);

   BEGIN
       IF Value <> FIncludeHiddenFiles THEN
      BEGIN
          FIncludeHiddenFiles := Value;
         IF Value THEN
             SearchFilesMask := SearchFilesMask OR faHidden
         ELSE
             SearchFilesMask := SearchFilesMask AND (NOT faHidden);
      END;
   END;

   PROCEDURE TDirectory.SetIncludeSystemFiles (Value : BOOLEAN);

   BEGIN
       IF Value <> FIncludeSystemFiles THEN
      BEGIN
          FIncludeSystemFiles := Value;
         IF Value THEN
             SearchFilesMask := SearchFilesMask OR faSysfile
         ELSE
             SearchFilesMask := SearchFilesMask AND NOT faSysfile
      END;
   END;

   PROCEDURE TDirectory.SetIncludeVolumeID (Value : BOOLEAN);

   BEGIN
       IF Value <> FIncludeVolumeID THEN
      BEGIN
          FIncludeVolumeID := Value;
         IF Value THEN
             SearchFilesMask := SearchFilesMask OR faVolumeID
         ELSE
             SearchFilesMask := SearchFilesMask AND NOT faVolumeID
      END
   END;

   PROCEDURE TDirectory.SetIncludeDirectoryFiles (Value : BOOLEAN);

   BEGIN
       IF NOT Value AND FOnlyDirectories THEN
          Raise EDirectoryError.Create('Invalide exclusion');
{          Raise EDirectoryError.CreateRes(RS_InvalidDirectoryExclusion);}
       IF Value <> FIncludeDirectoryFiles THEN
      BEGIN
          FIncludeDirectoryFiles := Value;
         IF Value THEN
             SearchFilesMask := SearchFilesMask OR faDirectory
         ELSE
             SearchFilesMask := SearchFilesMask AND NOT faDirectory
      END
   END;

   PROCEDURE TDirectory.SetExcludeNormalDir (Value : BOOLEAN);

   BEGIN
       IF Value <> FExcludeNormalDir THEN
          FExcludeNormalDir := Value;
   END;

   PROCEDURE TDirectory.SetExcludeReadOnlyDir (Value : BOOLEAN);

   BEGIN
       IF Value <> FExcludeReadOnlyDir THEN
      BEGIN
          FExcludeReadOnlyDir := Value;
         IF Value THEN
             ExcludedDirMask := ExcludedDirMask OR faReadOnly
         ELSE
             ExcludedDirMask := ExcludedDirMask AND NOT faReadOnly
      END;
   END;

   PROCEDURE TDirectory.SetExcludeArchiveDir (Value : BOOLEAN);

   BEGIN
       IF Value <> FExcludeArchiveDir THEN
      BEGIN
          FExcludeArchiveDir := Value;
         IF Value THEN
             ExcludedDirMask := ExcludedDirMask OR faArchive
         ELSE
             ExcludedDirMask := ExcludedDirMask AND NOT faArchive
      END;
   END;

   PROCEDURE TDirectory.SetIncludeHiddenDir (Value : BOOLEAN);

   BEGIN
       IF Value <> FIncludeHiddenDir THEN
      BEGIN
          FIncludeHiddenDir := Value;
         IF Value THEN
             SearchDirMask := SearchDirMask OR faHidden
         ELSE
             SearchDirMask := SearchDirMask AND NOT faHidden
      END;
   END;

   PROCEDURE TDirectory.SetIncludeSystemDir (Value : BOOLEAN);

   BEGIN
       IF Value <> FIncludeSystemDir THEN
      BEGIN
          FIncludeSystemDir := Value;
         IF Value THEN
             SearchDirMask := SearchDirMask OR faSysfile
         ELSE
             SearchDirMask := SearchDirMask AND NOT faSysfile
      END;
   END;

    PROCEDURE TDirectory.SetStopStatus(Value : BOOLEAN);

    BEGIN
        if FStopStatus <> Value THEN
            FStopStatus := Value;
        if Assigned(FOnSearchStatus) then FOnSearchStatus(Self);
    END;

    PROCEDURE TDirectory.SetInSubDirectories (Value : BOOLEAN);

    BEGIN
        IF FInSubDirectories <> Value THEN
            FInSubDirectories:= Value;
    END;

   PROCEDURE TDirectory.SetOnlyDirectories (Value : BOOLEAN);

   BEGIN
       IF Value and NOT FIncludeDirectoryFiles THEN
{          Raise EDirectoryError.Create('Invalid restriction');}
          Raise EDirectoryError.CreateRes(RS_InvalidDirectoryRestriction);
       IF FOnlyDirectories <> Value THEN
          FOnlyDirectories := Value;
   END;

    PROCEDURE TDirectory.SetFileFilter(CONST Value : STRING);

    VAR
        FileFilter : STRING;

    BEGIN
        FileFilter := Value;
        IF NOT ValidFilter(FileFilter) THEN
            exit;
        IF (FFileFilter^ <> FileFilter) THEN
            AssignStr(FFileFilter, FileFilter);
    END;

    FUNCTION TDirectory.GetFileFilter : String;

    BEGIN
        Result := FFileFilter^
    END;

    PROCEDURE TDirectory.SetDirectoryFilter(CONST Value : STRING);

    VAR
        DirectoryFilter: STRING;

    BEGIN
        DirectoryFilter := Value;
        IF ValidFilter(DirectoryFilter)
        AND (FDirectoryFilter^ <> DirectoryFilter) THEN
            AssignStr(FDirectoryFilter, DirectoryFilter);
    END;

    FUNCTION TDirectory.GetDirectoryFilter : String;

    BEGIN
        Result := FDirectoryFilter^
    END;

    PROCEDURE TDirectory.SetDirectoryInTreatment(Value : T_DirectoryName);

    BEGIN
        IF Value <> FDirectoryInTreatment^ THEN
            AssignStr(FDirectoryInTreatment, Value)
    END;

    FUNCTION TDirectory.GetDirectoryInTreatment : T_DirectoryName;

    BEGIN
        Result := FDirectoryInTreatment^
    END;

    PROCEDURE TDirectory.SetSelectedFileName(Value : T_DirectoryName);

    BEGIN
        IF Value <> FSelectedFileName^ THEN
            AssignStr(FSelectedFileName, Value);
    END;

    FUNCTION TDirectory.GetSelectedFileName : T_DirectoryName;

    BEGIN
        Result := FSelectedFileName^
    END;

   FUNCTION TDirectory.GetVersion : String;

   BEGIN
       Result := FVersion^;
   END;

   PROCEDURE TDirectory.SetVersion(Value : String);

   BEGIN
        IF Value <> FVersion^ THEN
            AssignStr(FVersion, KVersion);
   END;

    procedure Register;

    begin
        RegisterComponents('AgVCL', [TDirectory]);
    end;
end.